home *** CD-ROM | disk | FTP | other *** search
/ United Public Domain Gold 4 / United Public Domain Gold 4.iso / fredfish / ff.0773.dms / ff.0773.adf / REXXProgs / Palette.rexx next >
OS/2 REXX Batch file  |  1992-12-05  |  14KB  |  720 lines
  1. /*        $VER: 1.0 Palette.rexx 7 Dec 1991 (7.12.91)
  2.     copyright 1991 Richard Lee Stockton and Gramma Software.
  3.       FREELY DISTRIBUTABLE as long as this notice remains
  4.  
  5. USAGE: rx Palette [public_screen] [colors] [replyport]
  6.       defaults to Workbench with 4 colors, no replyport
  7.  
  8. ASYNCH example:  ADDRESS AREXX Palette MY8COLORSCREEN 8 MYPORT
  9.  
  10.   Palette.rexx will return 5 if the user selects "USE" and if
  11.   Palette.rexx was given a replyport name, the message 'NEW_COLORS'
  12.   is sent to the replyport. Otherwise no message is sent and the
  13.   function returns 0.
  14.  
  15.  
  16. WARNING! There is no way to check to see if colors is the correct
  17. number for a particular screen. Colors *MUST* be either 2, 4, 8,
  18. 16, or 32, and too large a number will cause the requester to fail!
  19.  
  20.         requires these external libraries:
  21.                             arp.library
  22.                     rexxsupport.library
  23.                      rexxarplib.library
  24.                     screenshare.library
  25.  
  26. Author's Note:
  27.  I have tried to include plenty of comments in the hope that someone
  28. might use it as a starting point for their own application. Hack away!
  29.  
  30. */
  31.  
  32.  
  33.  
  34.  
  35. /*
  36.   make sure the needed libraries are available, and away we go!
  37. */
  38.  
  39. IF ~SHOW('L','rexxsupport.library') THEN
  40.   CALL ADDLIB('rexxsupport.library',0,-30,0)
  41. IF ~SHOW('L','rexxarplib.library') THEN
  42.   CALL ADDLIB('rexxarplib.library',0,-30,0)
  43.  
  44.  
  45.  
  46. /*
  47.   We'll need to know what OS version and what CPU
  48. */
  49.  
  50. CALL getversions()
  51.  
  52.  
  53.  
  54.  
  55. /*
  56.   get arguments and/or set defaults
  57. */
  58.  
  59. PARSE ARG pscreen' 'colors' 'replyport .
  60. IF colors~=2 & colors~=8 & colors~=16 & colors~=32 THEN colors=4
  61.  
  62.  
  63.  
  64.  
  65.  
  66. /*
  67.   Under 2.0, "Workbench" is a Public_Screen so we can use the Palette.
  68.   Under 1.3, Palette needs a custom screenshare screen.
  69. */
  70.  
  71. IF pscreen='' THEN pscreen='Workbench'
  72. IF pscreen='Workbench' & ksversion<37 THEN
  73.   CALL ALL_DONE('Can not open Palette on pre-2.0 WorkBench!')
  74.  
  75.  
  76.  
  77.  
  78.  
  79. /*
  80.   Find a free hostport. Multiple invocations may co-exist on the
  81.   same or multiple screens, but only one palette per replyport.
  82.   In that case, tell that palette to come to the front.
  83. */
  84.  
  85. host='PALETTEHOST'
  86. port='PALETTEPORT'
  87. IF replyport='' THEN
  88.   DO
  89.     DO i=1 WHILE SHOW('P',host||i)
  90.     END
  91.     host=host||i
  92.     port=port||i
  93.   END
  94. ELSE
  95.   DO
  96.     host=host'.'replyport
  97.     port=port'.'replyport
  98.     IF SHOW('P',port) THEN
  99.       DO
  100.         INTERPRET ADDRESS port FRONT
  101.         EXIT(0)
  102.       END
  103.   END
  104.  
  105.  
  106.  
  107.  
  108. /*
  109.   take care of mundane stuff
  110. */
  111.  
  112. CALL setup_variables()
  113.  
  114.  
  115.  
  116.  
  117. /*
  118.   We need a HOST to set up our window in
  119. */
  120.  
  121. CALL setup_host()
  122.  
  123.  
  124.  
  125.  
  126. /*
  127.   open the window with menus and gadgets and graphics, oh my!
  128.   Note the CLOSEWINDOW WINDOWCLOSE pair. w.flags tells the HOST
  129.   what gadgets we want, w.idcmp tells it what kinds of messages
  130.   we want to recieve.
  131. */
  132.  
  133. w.=''
  134. w.idcmp='CLOSEWINDOW+MENUPICK+GADGETDOWN+GADGETUP+MOUSEBUTTONS'
  135. w.flags='WINDOWCLOSE+WINDOWDRAG'
  136.  
  137.  
  138.  
  139.  
  140. /*
  141.   If we have a replyport we can identify it in the title. The
  142.   extra spaces at the end are to fill out the rest of the 1.3
  143.   titleline. Under 2.0 these spaces are not necessary.
  144. */
  145.  
  146. w.title=' ARexx Color Palette           '
  147. IF replyport~='' THEN w.title=' 'replyport' Colors          '
  148.  
  149.  
  150.  
  151.  
  152. /*
  153.   Note how the palette always opens centered in the screen
  154.   This is easier to do with a rexxarplib window as opposed to
  155.   a requester since Request() is auto-magically sized.
  156.   Also note how you can continue a line of sourcecode simply by
  157.   adding an extra "," at the end of any line that is continued.
  158. */
  159.  
  160. xmax=218
  161. ymax=126
  162. CALL OpenWindow(host,(ScreenCols(pscreen)-xmax)%2, ,
  163.                      (ScreenRows(pscreen)-ymax)%2, ,
  164.                      xmax,ymax,w.idcmp,w.flags,w.title)
  165.  
  166.  
  167.  
  168.  
  169. /*
  170.   Make sure our text images will be correct, no matter what...
  171. */
  172.  
  173. CALL SetFont(host,'topaz.font',8)
  174.  
  175.  
  176.  
  177.  
  178. /*
  179.   Try to adjust a little for 1.3 by changing color registers
  180. */
  181.  
  182. p1=1
  183. p2=2
  184. IF ksversion<37 THEN
  185.   DO
  186.     p1=2
  187.     p2=1
  188.     CALL SetReqColor(host,'OKAYPEN',1)
  189.   END
  190.  
  191.  
  192.  
  193.  
  194. /*
  195.   Add X and Y position to the message that MOUSEBUTTONS sends.
  196.   Now instead of plain MOUSEBUTTONS messages, we get SELECTUP
  197.   or SELECTDOWN and the location, ie, "SELECTUP 267 59".
  198.   If the mouse is over a gadget the appropriate GADGET message
  199.   is sent instead.
  200. */
  201.  
  202. CALL ModifyHost(host,MOUSEBUTTONS,"%b %x %y")
  203.  
  204.  
  205.  
  206.  
  207. /*
  208.   Menu  -  AddMenu(host, text, message, hotkey)
  209. */
  210.  
  211. CALL AddMenu(host,'ARexx Palette')
  212. CALL AddItem(host,'Use     ','OK','U')
  213. CALL AddItem(host,'Reset   ','RESET','R')
  214. CALL AddItem(host,'About   ','ABOUT')
  215. CALL AddItem(host,'Quit    ','CLOSEWINDOW','Q')
  216.  
  217.  
  218.  
  219.  
  220. /*
  221.   Gadgets  -  AddGadget(host, left, top, gadget_id, text, message)
  222.   6 color adjuster Gadgets, 2 each for the Red Green and Blue guns.
  223. */
  224.  
  225. CALL AddGadget(host,15,26,1,'<','%l 1 -1')
  226. CALL AddGadget(host,51,26,2,'>','%l 1 1')
  227. CALL AddGadget(host,85,26,3,'<','%l 2 -1')
  228. CALL AddGadget(host,121,26,4,'>','%l 2 1')
  229. CALL AddGadget(host,155,26,5,'<','%l 3 -1')
  230. CALL AddGadget(host,191,26,6,'>','%l 3 1')
  231.  
  232.  
  233.  
  234.  
  235. /*
  236.   Labels for the color adjust gadgets
  237. */
  238.  
  239. CALL SetAPen(host,1)
  240. CALL Move(host,27,22)
  241. CALL Text(host,'Red')
  242. CALL Move(host,89,22)
  243. CALL Text(host,'Green')
  244. CALL Move(host,163,22)
  245. CALL Text(host,'Blue')
  246.  
  247.  
  248.  
  249.  
  250. /*
  251.   A little graphics to make everything look nicer.
  252.   box(host,upleft_color,bottomright_color,leftedge,topedge,width,height)
  253. */
  254.  
  255. DO i=1 TO 3
  256.   CALL box(host,p1,p1,8+(i-1)*70,13,61,26)
  257. END
  258. CALL box(host,p1,p2,53,42,108,10)
  259. CALL box(host,p1,p1,15,55,186,50)
  260. CALL read_colors()
  261.  
  262.  
  263.  
  264.  
  265. /*
  266.   get the current colors from the screen
  267. */
  268.  
  269. CALL read_colors()
  270.  
  271.  
  272.  
  273.  
  274. /*
  275.   system-type gadgets
  276. */
  277.  
  278. CALL AddGadget(host,11,ymax-16,98,' USE ','OK')
  279. CALL AddGadget(host,xmax%2-24,ymax-16,99,'RESET','RESET')
  280. CALL AddGadget(host,xmax-64,ymax-16,99,'CANCEL','CLOSEWINDOW')
  281.  
  282.  
  283.  
  284. /*
  285.   bring this window to the front and activate it
  286. */
  287.  
  288. CALL tofront()
  289.  
  290.  
  291.  
  292.  
  293. /*
  294.   MAIN message loop
  295. */
  296.  
  297. keep_going=1
  298. DO WHILE keep_going=1
  299.  
  300.  
  301.  
  302.  
  303. /*
  304.   Wait for at least one message to arrive
  305. */
  306.  
  307.   t=WAITPKT(port)
  308.  
  309.  
  310.  
  311.  
  312. /*
  313.   process *ALL* the messages waiting at this port
  314. */
  315.  
  316.   DO ff=1
  317.     p=GETPKT(port)
  318.  
  319.  
  320.  
  321.  
  322. /*
  323.   p=NULL means not more messages at this port.
  324.   This is the *ONLY* time you should leave this loop!
  325. */
  326.  
  327.     IF p='0000 0000'x THEN LEAVE ff    /* message port empty */
  328.  
  329.  
  330.  
  331.  
  332. /*
  333.   get the message from the the port packet
  334. */
  335.  
  336.     command=GETARG(p)
  337.  
  338.  
  339.  
  340.  
  341. /*
  342.   REPLY() as soon as you can, as soon as you are through extracting
  343.   data from the packet with GETARG()
  344. */
  345.  
  346.     t=REPLY(p,0)
  347.  
  348.  
  349.  
  350.  
  351. /*
  352.   Ignore any messages received after the CLOSEWINDOW
  353. */
  354.  
  355.     IF keep_going=0 THEN ITERATE ff
  356.  
  357.  
  358.  
  359.  
  360. /*
  361.   now we can see what the message contains, and act on it
  362. */
  363.  
  364.     PARSE VAR command arg1' 'arg2' 'arg3' ' 
  365.     SELECT
  366.       WHEN arg1='CLOSEWINDOW'  THEN keep_going=0
  367.       WHEN arg1='RESET'        THEN CALL reset_colors()
  368.       WHEN arg1='OK'           THEN CALL do_ok()
  369.       WHEN arg1='FRONT'        THEN CALL tofront()
  370.       WHEN arg1='GADGETDOWN'   THEN CALL gadgetdown(arg2 arg3)
  371.       WHEN arg1='SELECTDOWN'   THEN CALL selectdown(arg2 arg3)
  372.       WHEN arg1='ABOUT'        THEN CALL Request(,,copyright,,,,pscreen)
  373.       WHEN arg1='GADGETUP'     THEN NOP
  374.       WHEN arg1='SELECTUP'     THEN NOP
  375.       WHEN arg1='CONTINUE'     THEN NOP
  376.  
  377.  
  378. /*
  379.   display all messages not otherwise handled in this select loop so
  380.   we can see what is happening when things go wrong.
  381.   This is a good debugging OTHERWISE for any SELECT loop.
  382. */
  383.  
  384.       OTHERWISE CALL REQUEST(,100,arg1 arg2 arg3,,,,pscreen)
  385.     END
  386.   END
  387. END
  388. CALL ALL_DONE('RESET')
  389. EXIT(0)
  390.  
  391.  
  392.  
  393.  
  394. /* Functions */
  395.  
  396. /*
  397.   send all endings thru here so we can clean up
  398. */
  399.  
  400. ALL_DONE:
  401.   PARSE ARG air
  402.   changed=0
  403.   CALL PostMsg()
  404.   IF air='RESET' THEN CALL reset_colors()
  405.   ELSE IF air='NEW_COLORS' THEN changed=5
  406.   ELSE IF air~='' THEN
  407.     DO
  408.       CALL usermsg(air)
  409.       CALL waiting()
  410.     END
  411.   CALL clearport(port)
  412.   IF SHOW('P',host) THEN CALL Stop(host)
  413.   EXIT(changed)
  414. RETURN
  415.  
  416.  
  417.  
  418.  
  419. /*
  420.   remove all waiting messages from a port.
  421.   In most cases this shouldn't be required if you have handled
  422.   your message port loop properly. Doesn't hurt though.....-)
  423. */
  424.  
  425. clearport:
  426. PARSE ARG portname
  427. p=1
  428. DO FOREVER
  429.   p=GETPKT(portname)
  430.   IF p='0000 0000'x THEN RETURN
  431.   t=REPLY(p,0)
  432. END
  433. RETURN
  434.  
  435.  
  436.  
  437.  
  438. /*
  439.   Colors accepted, send message to replyport and quit
  440. */
  441.  
  442. do_ok:
  443.   IF replyport~='' THEN
  444.     IF SHOWLIST('P',replyport) THEN
  445.       INTERPRET ADDRESS replyport 'NEW_COLORS'
  446.   CALL ALL_DONE('NEW_COLORS')
  447. RETURN
  448.  
  449.  
  450.  
  451.  
  452. tofront:
  453.   CALL ActivateWindow(host)
  454.   CALL WindowToFront(host)
  455.   CALL ScreenToFront(pscreen)
  456. RETURN
  457.  
  458.  
  459.  
  460.  
  461. /*
  462.   set box-size and put colors in the selection area
  463.   also stores the currently displayed colors in the stem "colors."
  464. */
  465.  
  466. read_colors:
  467.   colors.=''
  468.   box_x=92
  469.   box_y=48
  470.   IF colors>8 THEN
  471.     DO
  472.       box_y=12
  473.       box_x=46
  474.       IF colors=32 THEN box_x=23
  475.     END
  476.   ELSE IF colors>2 THEN
  477.     DO
  478.       box_y=24
  479.       IF colors=8 THEN box_x=46
  480.     END
  481.   box_cols=184%box_x
  482.   box_rows=48%box_y
  483.   DO i=0 TO colors-1
  484.     colors.i=ScreenColor(pscreen,i)
  485.     CALL SetAPen(host,i)
  486.     CALL RectFill(host,16+(i//box_cols)*box_x,56+(i%box_cols)*box_y,16+box_x+(i//box_cols)*box_x,56+box_y+(i%box_cols)*box_y)
  487.   END
  488.   CALL SetAPen(host,1)
  489.  
  490.  
  491.  
  492.  
  493. /*
  494.   Note how the previous routine has no RETURN and so will "fall through"
  495.   to this next routine. Careful placement of routines can save lines of code.
  496.  
  497.   This routine resets the color data to when the palette was last drawn.
  498. */
  499.  
  500. reset_colors:
  501.   DO i=0 TO colors-1
  502.     DO j=1 TO 3
  503.       colors.i.j=WORD(colors.i,j)%1
  504.     END
  505.   END
  506.  
  507.  
  508.  
  509.  
  510. /*
  511.   This routine actually changes the colors using the "colors.i.j" data
  512. */
  513.  
  514. set_colors:
  515.   DO i=0 TO colors-1
  516.     CALL ScreenColor(pscreen,i,colors.i.1,colors.i.2,colors.i.3)
  517.   END
  518.  
  519.  
  520.  
  521.  
  522. /*
  523.   Fills in the color number, RGB values, and the current color rectangle
  524. */
  525.  
  526. update_colors:
  527.   register=register%1
  528.   CALL Move(host,22,50)
  529.   CALL Text(host,RIGHT(register,2))
  530.   CALL Move(host,xmax-44,50)
  531.   CALL Text(host,d2x(colors.register.1)||d2x(colors.register.2)||d2x(colors.register.3))
  532.   DO i=1 TO 3
  533.     CALL Move(host,31+(i-1)*70,33)
  534.     CALL Text(host,right(colors.register.i%1,2))
  535.   END
  536.   CALL SetAPen(host,register)
  537.   CALL RectFill(host,54,43,160,51)
  538.   CALL SetAPen(host,1)
  539. RETURN
  540.  
  541.  
  542.  
  543.  
  544. /*
  545.   Changing RGB values - we limit them to valid values, 0 to 15
  546.   Note use of the internal message loop to speed event processing.
  547.   As long as the message remains GADGETDOWN, this routine will continue
  548.   to cycle, but if the button is released over the gadget (GADGETUP) or
  549.   has been moved off the gadget (SELECTUP) the cycling stops.
  550.   If we hadn't run ModifyHost(), SELECTUP would be replaced by MOUSEBUTTONS.  
  551. */
  552.  
  553. gadgetdown:
  554.   PARSE ARG rgb updown .
  555.   DO icount=1
  556.     colors.register.rgb=colors.register.rgb+updown
  557.     IF colors.register.rgb<0 THEN colors.register.rgb=15
  558.     IF colors.register.rgb>15 THEN colors.register.rgb=0
  559.     CALL ScreenColor(pscreen,register,colors.register.1,colors.register.2,colors.register.3)
  560.     CALL update_colors()
  561.     IF cpu>68000 THEN CALL DELAY(2)
  562.     p=GETPKT(port)
  563.     IF p~='0000 0000'x THEN
  564.       DO
  565.         arg1=GETARG(p)
  566.         t=REPLY(p,0)
  567.         PARSE VAR arg1 arg1 .
  568.         IF arg1="GADGETUP" | arg1="SELECTUP" | arg1='MOUSEBUTTONS' THEN
  569.           LEAVE icount
  570.       END
  571.   END
  572. RETURN
  573.  
  574.  
  575.  
  576.  
  577. /*
  578.   Selection of the color register to change using the size of the
  579.   filled in box to figure out which color the user wants.
  580.   Selections outside the color-selection-rectangle are ignored.
  581. */
  582.  
  583. selectdown:
  584.   IF arg2<14 | arg2>198 | arg3<55 | arg3>103 THEN RETURN
  585.   mx=(arg2-14)%box_x
  586.   my=(arg3-55)%box_y
  587.   IF mx>=box_cols THEN mx=box_cols-1
  588.   IF my>=box_rows THEN my=box_rows-1
  589.   register=mx+my*box_cols
  590.   CALL update_colors()
  591. RETURN
  592.  
  593.  
  594.  
  595.  
  596. /*
  597.   Box routine to draw 2.0 style boxes.
  598.   Note that the box is 1 pixel wider than asked for on BOTH sides,
  599.   so width is really width+2 although height is correct.
  600.   Assuming register 1 is dark and register 2 is bright...
  601.     pen1  pen2  effect
  602.     ----  ----  ------
  603.      1     1    plain
  604.      1     2    recessed
  605.      2     1    raised
  606. */
  607.  
  608. box:
  609.   ARG boxhost,pen1,pen2,upleft,uptop,width,height
  610.   CALL SetAPen(boxhost,pen2)
  611.   CALL Move(boxhost,upleft+width+1,uptop)
  612.   CALL Draw(boxhost,upleft+width+1,uptop+height)
  613.   CALL Draw(boxhost,upleft-1,uptop+height)
  614.   CALL Move(boxhost,upleft+width,uptop+1)
  615.   CALL Draw(boxhost,upleft+width,uptop+height)
  616.   CALL SetAPen(boxhost,pen1)
  617.   CALL Move(boxhost,upleft,uptop)
  618.   CALL Draw(boxhost,upleft+width,uptop)
  619.   CALL Move(boxhost,upleft,uptop+height-1)
  620.   CALL Draw(boxhost,upleft,uptop)
  621.   CALL Move(boxhost,upleft-1,uptop)
  622.   CALL Draw(boxhost,upleft-1,uptop+height)
  623. RETURN
  624.  
  625.  
  626.  
  627.  
  628. /*
  629.   Creates a place where messages can be recieved by rexxarplib
  630.   and acted upon. The HOST is where you direct your requests
  631.   for windows and graphics and the like. The PORT is where the
  632.   HOST returns messages about what it has done or what gadgets,
  633.   menu items, etc. have been selected by the user.
  634.   We send commands to the HOST and get messages from the PORT.
  635. */
  636.  
  637. setup_host:
  638.   CALL OPENPORT(port)
  639.   ADDRESS AREXX "'x=CreateHost("host","port","pscreen")'"
  640.   DO 200 WHILE ~SHOW('Ports',host)
  641.     CALL DELAY 10  /* 200 ms */
  642.   END
  643.   IF ~SHOW('Ports',host) THEN
  644.     CALL ALL_DONE('Could not open host 'host'.')
  645.   IF ~SHOW('Ports',port) THEN
  646.     CALL ALL_DONE('Could not open port 'port'.')
  647. RETURN
  648.  
  649.  
  650.  
  651.  
  652. /*
  653.   Opens a message window
  654. */
  655.  
  656. usermsg:
  657.   PARSE ARG umsg
  658.   CALL PostMsg()
  659.   CALL PostMsg(0,160,umsg,pscreen)
  660. RETURN
  661.  
  662.  
  663.  
  664.  
  665. /* Wait long enough for the message to be read */
  666.  
  667. waiting:
  668.   CALL DELAY(200)
  669.   CALL PostMsg()
  670. RETURN
  671.  
  672.  
  673.  
  674.  
  675. /*
  676.   initialize
  677. */
  678.  
  679. setup_variables:
  680.   register=0
  681.   x=SOURCELINE(1)
  682.   copyright=''
  683.   DO i=3 TO 7
  684.     copyright=copyright WORD(x,i)
  685.   END
  686.   copyright=CENTER(STRIP(copyright),32)'\\
  687.   © 1991 Richard Lee Stockton\'CENTER('and',32)'\
  688.     Gramma Software Systems\
  689. 17730-15th Avenue NE, Suite 223\
  690.      Seattle WA 98155-3804\
  691.     Office: (206) 363-6417\
  692.        FAX:       361-0429\
  693.        BBS:       744-1254\
  694.       Tech:       776-1253\\
  695.       FREELY DISTRIBUTABLE'
  696. RETURN
  697.  
  698.  
  699.  
  700.  
  701. /*
  702.   Use DOS version command to get operating system version
  703.   Redirect it to a temporary RAM file and read that.
  704.   We can get the cpu type (68000,020,030,040) using the
  705.   VERSION keyword with the PARSE command.
  706. */
  707.  
  708. getversions:
  709.   ADDRESS COMMAND 'version >RAM:VERSION'
  710.   x=OPEN(f,'RAM:VERSION','R')
  711.   line=READLN(f)
  712.   CALL CLOSE(f)
  713.   CALL DELETE('RAM:VERSION')
  714.   ksversion=STRIP(WORD(line,3))
  715.   PARSE VERSION . . cpu .
  716. RETURN
  717.   
  718.  
  719. /* Palette.rexx */
  720.